home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue49 / Alfresco / PSProcs.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-07-25  |  7.1 KB  |  236 lines
  1. {*********************************************************}
  2. {* AAPSPrcs                                              *}
  3. {* Copyright (c) Julian M Bucknall 1998-1999             *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* Algorithms Alfresco postscript routines               *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. {Warning: this unit is very much a work in progress. It will be
  14.        changing often as I build up a set of routines (maybe even
  15.        classes) to create EPS files. At present, this unit is nothing
  16.        more than a set of experimental routines. JMB}
  17.  
  18. unit PSProcs;
  19.  
  20. interface
  21.  
  22. uses
  23.   SysUtils,
  24.   Classes;
  25.  
  26. const
  27.   AAPSArrowHeight = 9;
  28.   AAPSArrowWidth = 2;
  29.  
  30. type
  31.   TaaPSPoint = packed record
  32.     X, Y : integer;
  33.   end;
  34.   TaaPSPath = array [0..99] of TaaPSPoint; {!! 99 is arbitrary}
  35.  
  36.   TaaPSIndexes = array [1..10] of integer;
  37.  
  38. procedure AAPSOutputProlog(SList : TStrings);
  39. procedure AAPSOutputEpilog(SList: TStrings);
  40.  
  41. procedure AAPSDrawLine(SList: TStrings; FromX, FromY, ToX, ToY : integer);
  42. procedure AAPSDrawSquare(SList: TStrings; aX, aY, aWidth : integer);
  43. procedure AAPSDrawRect(SList: TStrings; aX, aY, aWidth, aHeight : integer);
  44. procedure AAPSTracePath(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  45. procedure AAPSDrawPath(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  46. procedure AAPSDrawPathFill(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  47. procedure AAPSDrawText(SList: TStrings; aSt : string; aX, aY, aPoint : integer);
  48. procedure AAPSDrawArrow(SList: TStrings; aPath : TaaPSPath);
  49. procedure AAPSDrawTextInBox(SList: TStrings; aSt : string; aX, aY, aPoint : integer;
  50.                         aIndexes : TaaPSIndexes; aInxSt : string);
  51.  
  52. implementation
  53.  
  54. procedure AAPSOutputProlog(SList : TStrings);
  55. begin
  56.   with SList do begin
  57.     Add('%!PS-Adobe-3.0 EPSF-3.0');
  58.     Add('%%BoundingBox: 0 0 450 720'); {!! should calculate the size}
  59.     Add('%%Pages: 1');
  60.     Add('gsave');
  61.   end;
  62. end;
  63.  
  64. procedure AAPSOutputEpilog(SList: TStrings);
  65. begin
  66.   with SList do begin
  67.     Add('showpage');
  68.     Add('grestore');
  69.   end;
  70. end;
  71.  
  72. procedure AAPSDrawRect(SList: TStrings; aX, aY, aWidth, aHeight : integer);
  73. begin
  74.   with SList do begin
  75.     Add(Format('%% draw a rect at (%d, %d) with width %d, height %d ',
  76.                [aX, aY, aWidth, aHeight]));
  77.     Add('newpath');
  78.     Add(Format('  %d %d moveto', [aX, aY]));
  79.     Add(Format('  %d 0 rlineto', [aWidth]));
  80.     Add(Format('  0 %d rlineto', [aHeight]));
  81.     Add(Format('  -%d 0 rlineto', [aWidth]));
  82.     Add('closepath');
  83.     Add('stroke');
  84.   end;
  85. end;
  86.  
  87. procedure AAPSDrawSquare(SList: TStrings; aX, aY, aWidth : integer);
  88. begin
  89.   AAPSDrawRect(SList, aX, aY, aWidth, aWidth);
  90. end;
  91.  
  92. procedure AAPSDrawLine(SList: TStrings; FromX, FromY, ToX, ToY : integer);
  93. begin
  94.   with SList do begin
  95.     Add('%% draw a line');
  96.     Add(Format('%d %d moveto', [FromX, FromY]));
  97.     Add(Format('%d %d lineto', [ToX, ToY]));
  98.     Add('stroke');
  99.   end;
  100. end;
  101.  
  102. procedure AAPSTracePath(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  103. var
  104.   i : integer;
  105. begin
  106.   with SList do begin
  107.     Add('%% trace a path');
  108.     Add('newpath');
  109.     Add(Format('%d %d moveto', [aPath[0].X, aPath[0].Y]));
  110.     for i := 1 to pred(aCount) do begin
  111.       Add(Format('%d %d lineto', [aPath[i].X, aPath[i].Y]));
  112.     end;
  113.     Add('closepath');
  114.   end;
  115. end;
  116.  
  117. procedure AAPSDrawPath(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  118. begin
  119.   with SList do begin
  120.     Add('%% draw a path');
  121.     AAPSTracePath(SList, aPath, aCount);
  122.     Add('stroke');
  123.   end;
  124. end;
  125.  
  126. procedure AAPSDrawPathFill(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  127. begin
  128.   with SList do begin
  129.     Add('%% draw a path and fill');
  130.     AAPSTracePath(SList, aPath, aCount);
  131.     Add('fill');
  132.   end;
  133. end;
  134.  
  135. procedure AAPSDrawText(SList: TStrings; aSt : string; aX, aY, aPoint : integer);
  136. begin
  137.   with SList do begin
  138.     Add(Format('%% draw text at (%d, %d) with point size %d', [aX, aY, aPoint]));
  139.     Add(Format('%d %d moveto', [aX, aY]));
  140.     Add(Format('/Helvetica findfont %d scalefont setfont', [aPoint]));
  141.     Add(Format('(%s) show', [aSt]));
  142.   end;
  143. end;
  144.  
  145. procedure AAPSDrawArrow(SList: TStrings; aPath : TaaPSPath);
  146. var
  147.   Path : TaaPSPath;
  148.   Sign : integer;
  149.   Theta : double;
  150.   aX, aY, aToX, aToY : integer;
  151. begin
  152.   aX := aPath[0].X;
  153.   aY := aPath[0].Y;
  154.   aToX := aPath[1].X;
  155.   aToY := aPath[1].Y;
  156.   if (aToX = aX) then begin
  157.     {vertical}
  158.     if (aToY > aY) then
  159.       Sign := 1
  160.     else
  161.       Sign := -1;
  162.     Path[0].X := aX;
  163.     Path[0].Y := aToY - (Sign * AAPSArrowHeight);
  164.     Path[1].X := aX - AAPSArrowWidth;
  165.     Path[1].Y := Path[0].Y;
  166.     Path[2].X := aToX;
  167.     Path[2].Y := aToY;
  168.     Path[3].X := aX + AAPSArrowWidth;
  169.     Path[3].Y := Path[0].Y;
  170.   end
  171.   else begin
  172.     {other angle}
  173.     Theta := arctan((aToY - aY) / (aToX - aX));
  174.     if (aToX > aX) then
  175.       Sign := 1
  176.     else
  177.       Sign := -1;
  178.     Path[0].X := Round(aToX - Sign * (AAPSArrowHeight * cos(Theta)));
  179.     Path[0].Y := Round(aToY - Sign * (AAPSArrowHeight * sin(Theta)));
  180.     Path[1].X := Round(Path[0].X - Sign * (AAPSArrowWidth * sin(Theta)));
  181.     Path[1].Y := Round(Path[0].Y + Sign * (AAPSArrowWidth * cos(Theta)));
  182.     Path[2].X := aToX;
  183.     Path[2].Y := aToY;
  184.     Path[3].X := Round(Path[0].X + Sign * (AAPSArrowWidth * sin(Theta)));
  185.     Path[3].Y := Round(Path[0].Y - Sign * (AAPSArrowWidth * cos(Theta)));
  186.   end;
  187.   with SList do begin
  188.     Add(Format('%d %d moveto', [aX, aY]));
  189.     Add(Format('%d %d lineto', [Path[0].X, Path[0].Y]));
  190.     Add('stroke');
  191.     AAPSDrawPathFill(SList, Path, 4);
  192.   end;
  193. end;
  194.  
  195.  
  196. procedure AAPSDrawTextInBox(SList: TStrings; aSt : string; aX, aY, aPoint : integer;
  197.                         aIndexes : TaaPSIndexes; aInxSt : string);
  198. var
  199.   Width : integer;
  200.   i     : integer;
  201.   BumpCenter : integer;
  202.   X          : integer;
  203.   Arrow      : TaaPSPath;
  204. begin
  205.   {draw the boxes and text}
  206.   Width := aPoint * 3 div 2;
  207.   BumpCenter := (Width - aPoint);
  208.   X := aX;
  209.   for i := 1 to length(aSt) do begin
  210.     AAPSDrawSquare(Slist, X, aY, Width);
  211.     AAPSDrawText(SList, aSt[i], X + BumpCenter, aY + BumpCenter, aPoint);
  212.     inc(X, Width);
  213.   end;
  214.   {draw the shadow}
  215.   with SList do begin
  216.     Add('gsave');
  217.     Add('  3 setlinewidth');
  218.     Add(Format('  %d %d moveto', [aX+1, aY-1]));
  219.     Add(Format('  %d 0 rlineto', [Width * length(aSt)]));
  220.     Add(Format('  0 %d rlineto', [Width]));
  221.     Add('  stroke');
  222.     Add('grestore');
  223.   end;
  224.   for i := 1 to length(aInxSt) do begin
  225.     X := aX + (Width * (aIndexes[i] - 1));
  226.     Arrow[0].X := X + (Width div 2);
  227.     Arrow[0].Y := aY - (2 * AAPSArrowHeight);
  228.     Arrow[1].X := Arrow[0].X;
  229.     Arrow[1].Y := aY - 4;
  230.     AAPSDrawArrow(SList, Arrow);
  231.     AAPSDrawText(SList, aInxSt[i], X + BumpCenter, Arrow[0].Y - aPoint, aPoint);
  232.   end;
  233. end;
  234.  
  235. end.
  236.